home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Workbench Add-On
/
Workbench Add-On - Volume 1.iso
/
Dev
/
Oberon
/
source
/
ProjectOberon
/
Fonts.mod
< prev
next >
Wrap
Text File
|
1995-07-02
|
3KB
|
120 lines
(*************************************************************************
$RCSfile: Fonts.mod $
Description: Port of the Project Oberon Fonts module.
Interface based on module Fonts for the Ceres Oberon
System, created by J. Gutknecht (JG 27.8.90).
Created by: fjc (Frank Copeland)
$Revision: 1.14 $
$Author: fjc $
$Date: 1995/06/04 23:24:07 $
Copyright © 1994-1995, Frank Copeland.
This file is part of the Oberon-A Library.
See Oberon-A.doc for conditions of use and distribution.
*************************************************************************)
<* STANDARD- *>
MODULE Fonts;
IMPORT
SYS := SYSTEM, Kernel, e := Exec, d := Dos, gfx := Graphics,
df := DiskFont, str := Strings, conv := Conversions, as := AmigaSupport,
Display;
TYPE
Name * = ARRAY 32 OF CHAR;
Font * = POINTER TO FontDesc;
FontDesc * = RECORD
name * : Name;
height*, minX*, maxX*, minY*, maxY*: INTEGER;
raster*: Display.Font;
next : Font;
END; (* FontDesc *)
VAR
Default *, FontList : Font;
(*------------------------------------*)
PROCEDURE This * (name : ARRAY OF CHAR) : Font;
VAR
F : Font; attr : gfx.TextAttr; family, size : ARRAY 32 OF CHAR;
pathPart, filePart : e.LSTRPTR; height : LONGINT; tf : gfx.TextFontPtr;
<*$CopyArrays-*>
BEGIN (* This *)
F := FontList; WHILE (F # NIL) & (name # F.name) DO F := F.next END;
IF F = NIL THEN
COPY (name, family); pathPart := d.PathPart (family); pathPart[0] := 0X;
IF family # "" THEN
filePart := d.FilePart (name); COPY (filePart^, size);
IF conv.StrToInt (size, 10, height) THEN
SYS.NEW (attr.name, str.Length (family) + 1);
ASSERT (attr.name # NIL, 98);
COPY (family, attr.name^);
attr.ySize := SHORT (height);
attr.flags := {}; attr.style := {};
tf := df.OpenDiskFont (attr);
IF tf # NIL THEN
NEW (F); ASSERT (F # NIL, 98);
NEW (F.raster); ASSERT (F.raster # NIL, 98);
COPY (name, F.name); F.height := tf.ySize;
F.minX := 0; F.maxX := tf.xSize;
F.minY := tf.baseline - tf.ySize; F.maxY := tf.baseline;
F.raster.textFont := tf;
F.next := FontList; FontList := F
ELSE
RETURN Default
END;
ELSE
RETURN Default
END;
ELSE
RETURN Default
END;
END;
RETURN F
END This;
(*------------------------------------*)
PROCEDURE GetDefault ();
VAR defFont : gfx.TextFontPtr; ta : gfx.TextAttrPtr;
BEGIN (* GetDefault *)
defFont := as.scrFont;
NEW (Default); ASSERT (Default # NIL, 98);
NEW (Default.raster); ASSERT (Default.raster # NIL, 98);
Default.name := "Default"; Default.height := defFont.ySize;
Default.minX := 0; Default.maxX := defFont.xSize;
Default.minY := defFont.baseline - defFont.ySize;
Default.maxY := defFont.baseline;
Default.raster.textFont := defFont;
Default.next := FontList; FontList := Default
END GetDefault;
(*------------------------------------*)
PROCEDURE* Cleanup ( VAR rc : LONGINT );
VAR F : Font;
BEGIN (* Cleanup *)
F := FontList;
WHILE F # NIL DO
IF F.name # "Default" THEN gfx.CloseFont (F.raster.textFont) END;
F := F.next
END
END Cleanup;
BEGIN
Kernel.SetCleanup (Cleanup); as.OpenDisplay; GetDefault
END Fonts.